home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / PROGTOOL / LIB211.ZIP;1 / FRPG.PRG < prev    next >
Encoding:
Text File  |  1993-08-03  |  17.6 KB  |  431 lines
  1. *-----------------------------------------------------------------------
  2. *-- Program...: FRPG.PRG
  3. *-- Programmer: Ken Mayer (CIS: 71333,1030)
  4. *-- Date......: 07/29/1993
  5. *-- Notes.....: These are Fantasy Role-Playing Game routines. Some of
  6. *--             them can probably be used for other games ...
  7. *-----------------------------------------------------------------------
  8.  
  9. PROCEDURE SetRand
  10. *-----------------------------------------------------------------------
  11. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  12. *-- Date........: 02/18/1992
  13. *-- Notes.......: A small procedure used to set a random number table. 
  14. *--               Used with DICE(), etc. below, it can be quite handy. 
  15. *--               NOTE: You should use EITHER this routine, OR  
  16. *--               RAND(-1) (built in to dBASE).
  17. *-- Written for.: dBASE IV, 1.1
  18. *-- Rev. History: 02/18/1992 -- Original Release
  19. *-- Calls.......: None
  20. *-- Called by...: Any
  21. *-- Usage.......: Do SetRand
  22. *-- Example.....: Do SetRand
  23. *-- Returns.....: None
  24. *-- Parameters..: None
  25. *-----------------------------------------------------------------------
  26.  
  27.    private x,nSeed
  28.    m->nSeed = (val(substr(time(),1,2)) + val(substr(time(),4,2))+;
  29.               val(substr(time(),7,2))) * ;
  30.               val(substr(time(),7,2))
  31.    m->nX=int(rand(m->nSeed) * 6) + 1
  32.  
  33. RETURN
  34. *-- EoP: SetRand
  35.  
  36. FUNCTION Dice
  37. *-----------------------------------------------------------------------
  38. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  39. *-- Date........: 02/13/1992
  40. *-- Notes.......: A small function used to determine a random number 
  41. *--               from 1 to x. Used for gaming purposes.
  42. *-- Written for.: dBASE IV, 1.1
  43. *-- Rev. History: 05/23/1991 - original function.
  44. *--               02/13/1992 -- Ken Mayer -- discovered after playing 
  45. *--                with this that there are some problems with resetting
  46. *--                the random table each time. This has been removed. 
  47. *--                It also means that a couple of routines that used to 
  48. *--                be based on this can use it better (see: MULTDICE() 
  49. *--                below ...)
  50. *-- Calls.......: None
  51. *-- Called by...: Any
  52. *--               MULTDICE()       Function in FRPG.PRG
  53. *-- Usage.......: Dice(<nSides>)
  54. *-- Example.....: nVal = Dice(4)
  55. *-- Returns.....: Random # between 1 and <nSides>
  56. *-- Parameters..: nSides = # of sides of die to be cast ... (RPG dice
  57. *--                        include 4, 6 (standard), 8, 10, 12, 20, 100 
  58. *-----------------------------------------------------------------------
  59.  
  60.    parameters nSides
  61.  
  62.    *-- return a random number from 0 to nSides -1 and add 1 to it ...
  63. RETURN int(rand() * m->nSides) + 1
  64. *-- EoF: Dice()
  65.  
  66. FUNCTION MultDice
  67. *-----------------------------------------------------------------------
  68. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  69. *-- Date........: 02/13/1992
  70. *-- Notes.......: Function like above, used to determine a random #,
  71. *--               but for multiple dice, of x# of sides.
  72. *-- Written for.: dBASE IV, 1.1
  73. *-- Rev. History: 06/12/1991 - original function.
  74. *--               02/13/1992 -- cleaned up to call DICE() above for each
  75. *--                iteration, rather than calling once and then redoing 
  76. *--                the randomizer logic ... I was setting the random 
  77. *--                table in the DICE() function, but decided it was more
  78. *--                trouble than it was worth ... resetting it too fast
  79. *--                (i.e., in a loop) and I was getting the exact same 
  80. *--                number 2 to 4 times in a row ... not worth it. 
  81. *--                SO, I don't anymore.
  82. *-- Calls.......: DICE()               Function in FRPG.PRG
  83. *-- Called by...: Any
  84. *-- Usage.......: MultDice(<nNum>,<nSides>)
  85. *-- Example.....: nVal = MultDice(3,6)
  86. *-- Returns.....: Random value of 1 to x (x being number of sides), 
  87. *--               for each iteration (nNum), totalled. For example,
  88. *--               value returned would be the total of 3 six-sided die
  89. *--               rolled, the number would be anywhere from 3 to 18.
  90. *-- Parameters..: nNum   = Number of dice to be "rolled"
  91. *--               nSides = # of sides to the dice (see Dice() above)
  92. *-----------------------------------------------------------------------
  93.  
  94.    parameters nNum,nSides
  95.    private nCount,nTotal
  96.    
  97.    m->nCount = 0                         && set counter
  98.    m->nTotal = 0                         && set total
  99.    do while m->nCount < m->nNum          && loop for number of dice 
  100.       m->nCount = m->nCount + 1          && increment counter
  101.       m->nTotal = m->nTotal + dice(m->nSides) && add to total
  102.    enddo
  103.    
  104. RETURN m->nTotal
  105. *-- EoF: MultDice()
  106.  
  107. FUNCTION ValiDice
  108. *-----------------------------------------------------------------------
  109. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  110. *-- Date........: 06/08/1992
  111. *-- Notes.......: Used to ask user for input of a number within a range
  112. *--               based on gaming dice. Programmer supplies # of dice,
  113. *--               and number of sides to function, it returns the input
  114. *--               from the user (and only allows valid input).
  115. *-- Written for.: dBASE IV, 1.1
  116. *-- Rev. History: 07/09/1991 - original function.
  117. *--               02/13/1992 -- modified to handle user pressing <Esc>.
  118. *--               06/08/1992 -- explicit color handling
  119. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  120. *--               CENTER               Procedure in PROC.PRG
  121. *-- Called by...: Any
  122. *-- Usage.......: ValiDice(<nNum>,<nDice>,"<cMessage>","<cColor>")
  123. *-- Example.....: replace STRENGTH with ValiDice(3,6,"Strength",;
  124. *--                                       "rg+/gb,w/n,rg+/gb")  
  125. *-- Returns.....: Valid user input
  126. *-- Parameters..: nNum     = Number of dice
  127. *--               nSides   = Number of sides
  128. *--               cMessage = Message for line 0
  129. *--               cColor   = Colors for window
  130. *-----------------------------------------------------------------------
  131.  
  132.    PARAMETERS nNum, nDice, cMessage, cColor
  133.    private nUpper,nUser 
  134.    
  135.    save screen to sDice
  136.    activate screen
  137.    define window wDice from 8,20 to 14,60 double color &cColor.
  138.    do shadow with 8,20,14,60
  139.    activate window wDice
  140.    
  141.    m->nUpper = m->nNum * m->nDice    && upper limit
  142.    do center with 0,40,"",cMessage
  143.    do center with 1,40,"","Enter a value from "+;
  144.            ltrim(str(m->nNum))+" to "+ltrim(str(m->nUpper))
  145.    do center with 2,40,"","("+ltrim(str(m->nNum))+"d"+;
  146.            ltrim(str(m->nDice))+")"
  147.    m->nUser = 0
  148.    do while .t.
  149.       @4,18 get m->nUser picture "999" valid required ;
  150.                 m->nUser => m->nNum .and.;
  151.                 m->nUser =< m->nUpper;
  152.                 error chr(7)+"Enter a valid number!"
  153.       read 
  154.       if lastkey() = 27
  155.          ?? chr(7)
  156.       else
  157.          exit
  158.       endif
  159.    enddo
  160.  
  161.    release window wDice
  162.    restore screen from sDice
  163.    release screen sDice
  164.    
  165. RETURN m->nUser
  166. *-- EoF: ValiDice()
  167.  
  168. FUNCTION DiceChoose
  169. *-----------------------------------------------------------------------
  170. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  171. *-- Date........: 06/08/1992
  172. *-- Notes.......: This is another FRPG routine -- It is used to give the
  173. *--               user a choice of three die roles. The computer will
  174. *--               randomly generate a die roll three times so the user
  175. *--               has a choice. 
  176. *-- Written for.: dBASE IV, 1.1
  177. *-- Rev. History: 07/09/1991 - original function
  178. *--               02/13/1992 -- Modified to only require use of 
  179. *--               MULTDICE(), not a call to DICE() AND MULTDICE() ... 
  180. *--               also modified to deal with user pressing <Esc> 
  181. *--               (it beeps at 'em).
  182. *--               06/08/1992 -- Explicit color handling
  183. *-- Calls.......: MULTDICE()           Function in FRPG.PRG
  184. *--               SHADOW               Procedure in PROC.PRG
  185. *--               CENTER               Procedure in PROC.PRG
  186. *-- Called by...: Any
  187. *-- Usage.......: DiceChoose(<m->nNum>,<nSides>,"<nMessage>","<cColor>")
  188. *-- Example.....: replace STRENGTH with DiceChoose(3,6,;
  189. *--                      "To determine your character's Strength",;
  190. *--                      "rg+/gb,w+/n,rg+/gb")
  191. *-- Returns.....: The value of one of the choices displayed for the 
  192. *--               user, which will be a value from nNum to nNum*nSides
  193. *--                                                      + nNum+nPlus.
  194. *-- Parameters..: nNum     = number of dice to be rolled
  195. *--               nSides   = number of sides for each dice
  196. *--               cMessage = Message to be displayed at line 0 
  197. *--                          (max 40 Char)
  198. *--               cColor   = Colors for the window
  199. *-----------------------------------------------------------------------
  200.  
  201.    PARAMETERS nNum, nSides, cMessage, cColor
  202.    private nVal1,nVal2,nVal3,nUser
  203.    
  204.    *-- here we determine the three values for the user 
  205.    *-- (roll the dice)
  206.    m->nVal1 = multdice(m->nSides,m->nNum)
  207.    m->nVal2 = multdice(m->nSides,m->nNum)
  208.    m->nVal3 = multdice(m->nSides,m->nNum)
  209.    
  210.    *-- now we have the three values we need, define windows/menu 
  211.    activate screen
  212.    define window wDice from 8,20 to 17,60 double color &cColor.
  213.    save screen to sDice
  214.    define menu mDice                && as it says, define the menu
  215.    define pad  pChoice1 of mDice prompt ltrim(str(m->nVal1)) ;
  216.                                                       at 3,18
  217.    define pad  pChoice2 of mDice prompt ltrim(str(m->nVal2)) ;
  218.                                                       at 4,18
  219.    define pad  pChoice3 of mDice prompt ltrim(str(m->nVal3)) ;
  220.                                                       at 5,18
  221.    on selection pad pChoice1 of mDice deactivate menu
  222.    on selection pad pChoice2 of mDice deactivate menu
  223.    on selection pad pChoice3 of mDice deactivate menu
  224.    
  225.    *-- activate it all for user ...
  226.    do shadow with 8,20,17,60              && display shadow
  227.    activate window wDice                  && startup the window
  228.  
  229.    *-- display info in Window
  230.    do center with 0,40,"",cMessage
  231.    do center with 1,40,"","Choose a value from below:"
  232.    @3,15 say "1)"
  233.    @4,15 say "2)"
  234.    @5,15 say "3)"
  235.    do center with 7,40,"","Use Arrow keys, <Enter> to choose"
  236.    do while .t.
  237.       activate menu mDice                    && startup menu
  238.       if lastkey() = 27
  239.          ?? chr(7)
  240.       else
  241.          exit
  242.       endif
  243.    enddo
  244.    do case               && determine value to be returned
  245.       case pad() = "PCHOICE1"
  246.          m->nUser = m->nVal1
  247.       case pad() = "PCHOICE2"
  248.          m->nUser = m->nVal2
  249.       case pad() = "PCHOICE3"
  250.          m->nUser = m->nVal3
  251.    endcase
  252.    
  253.    *-- cleanup
  254.    release menu mDice
  255.    release window wDice
  256.    restore screen from sDice
  257.    release screen sDice
  258.    on escape
  259.    
  260. RETURN m->nUser
  261. *-- EoF: DiceChoose()
  262.  
  263. FUNCTION ParseDice
  264. *-----------------------------------------------------------------------
  265. *-- Programmer...: Ken Mayer (CIS: 71333,1030)
  266. *-- Date.........: 02/13/1992
  267. *-- Notes........: This is another gaming function ...
  268. *--                It's purpose is to read a string in the format  xdy+z
  269. *--                or some variation, and calculate the value ... 
  270. *--                x = # of dice, 
  271. *--                d = a part of the standard gaming syntax (i.e., 3d6),
  272. *--                y = # of sides of dice,
  273. *--                + = a modifier (could be a minus also ...)
  274. *--                z = number to modify each die rolled
  275. *--                (3d6+1 = a value from 6 to 21 (figure if you add 1 to 
  276. *--                 each die rolled, minimum value will be 6 (3+3), 
  277. *--                 maximum will be 21 (18+3))).)
  278. *-- Written for.: dBASE IV, 1.1
  279. *-- Rev. History: 08/29/1991 - original function.
  280. *--               02/13/1992 -- minor -- changed randomizer call to 
  281. *--                 DICE()
  282. *-- Calls.......: ALLTRIM()            Function in PROC.PRG
  283. *--               DICE()               Function in FRPG.PRG
  284. *-- Called by...: Any
  285. *-- Usage.......: ParseDice("<cDice>")
  286. *-- Example.....: ? ParseDice("5d6-3")
  287. *-- Returns.....: Random number from x (modified by z) to y (modified 
  288. *--               by z)
  289. *-- Parameters..: cDice = Standard gaming format value to be parsed and
  290. *--               calculated.
  291. *-----------------------------------------------------------------------
  292.  
  293.    parameter cDice    && value to parse and return a # from ...
  294.    private nCount,cDice,nPos,nNumDice,nMod,nDice,nPos2,nReturn
  295.    
  296.    m->cDice = upper(alltrim(m->cDice)) 
  297.    
  298.    if at("D",m->cDice) > 0      && if the letter 'D' is in there 
  299.       *-- get the VALUE of the "substring" of m->cDice, starting at
  300.       *-- character 1, going to the letter D and backing up 1.
  301.       *-- this will be useful in case we have 10dy ... otherwise,
  302.       *-- we _could_ assume only one character, but assumptions are
  303.       *-- bad ...
  304.       m->nPos = at("D",m->cDice)
  305.       m->nNumDice = val(substr(m->cDice,1,m->nPos-1))
  306.       m->nPos = m->nPos + 1  && move to character beyond letter 'D'
  307.       if at("+",m->cDice) > 0   && if we have a + modifier
  308.          m->nPos2 = at("+",m->cDice)
  309.          m->nDice = val(substr(m->cDice,m->nPos,m->nPos2-1))
  310.          m->nMod = val(substr(m->cDice,m->nPos2+1,len(m->cDice)-;
  311.                         m->nPos2))
  312.       else
  313.          if at("-",m->cDice) > 0 && if we have a - modifier
  314.             m->nPos2 = at("-",m->cDice)
  315.             m->nDice = val(substr(m->cDice,m->nPos,m->nPos2-1))
  316.             m->nMod = val(substr(m->cDice,m->nPos2+1,;
  317.                                    len(m->cDice)-m->nPos2))
  318.          else  && no modifier
  319.             m->nDice = val(substr(m->cDice,m->nPos,;
  320.                                    len(m->cDice)-m->nPos+1))
  321.          endif  && check for - sign
  322.       endif  && check for + sign
  323.       
  324.       *-- roll the m->nDice sided "dice" nNumDice number of times
  325.       m->nCount = 0
  326.       m->nReturn = 0
  327.       do while m->nCount < m->nNumDice
  328.          m->nCount = m->nCount + 1
  329.          m->nReturn = m->nReturn + dice(m->nDice)
  330.       enddo
  331.       
  332.       *-- Modifiers -- add or subtract appropriate value
  333.       if at("+",m->cDice) > 0  && if there's a + sign,
  334.          m->nReturn = m->nReturn + (m->nNumDice * m->nMod)
  335.       endif
  336.       if at("-",m->cDice) > 0  && it's a minus sign
  337.          m->nReturn = m->nReturn - (m->nNumDice * m->nMod)
  338.       endif
  339.       
  340.     else  && there's no letter 'D', so we simply have a number to 
  341.           && return this is under the assumption that the value 
  342.           && passed is either a random one, or (in this case) 
  343.           && it's a set value ... for example, in some cases 
  344.           && in my gaming system, HitPoints for a critter may 
  345.           && be a set value, in others it may be a random one.
  346.           && this routine handles both ...
  347.    
  348.           m->nReturn = val(m->cDice)
  349.       
  350.    endif
  351.  
  352. RETURN m->nReturn
  353. *-- EoF: ParseDice()
  354.  
  355. PROCEDURE PopDice
  356. *-----------------------------------------------------------------------
  357. *-- Programmer..: Ken Mayer (CIS: 71333,1030)
  358. *-- Date........: 06/08/1992
  359. *-- Notes.......: Used in my FRPG system as a Gamemaster's aid ... I can
  360. *--               simply press <Alt>D and have the system popup a window
  361. *--               over whatever I'm doing, ask for a "dice string" as in 
  362. *--               PARSEDICE(), and have it return a value. That way I'm 
  363. *--               not stuck digging for the dice in the middle of a 
  364. *--               situation that calls for a quick roll.
  365. *-- Written for.: dBASE IV, 1.1
  366. *-- Rev. History: 06/08/1992 -- Explicit color handling ...
  367. *-- Calls.......: SHADOW               Procedure in PROC.PRG
  368. *--               CENTER               Procedure in PROC.PRG
  369. *--               PARSEDICE()          Function in FRPG.PRG
  370. *-- Called by...: Any
  371. *-- Usage.......: Do PopDice with <cColor>
  372. *-- Example.....: ON KEY LABEL ALT-D DO POPDICE WITH ;
  373. *--                                             "RG+/GB,W+/N,RG+/GB"
  374. *-- Returns.....: None
  375. *-- Parameters..: cColor = window colors ...
  376. *-----------------------------------------------------------------------
  377.    parameters cColor
  378.    private cDice,cCursor 
  379.  
  380.    *-- setup
  381.    cCursor = set("CURSOR")
  382.    set cursor off
  383.    save screen to sPop  && save the screen
  384.    
  385.    activate screen
  386.    define window wPop from 7,20 to 15,60 double color &cColor.
  387.    do shadow with 7,20,15,60
  388.    activate window wPop
  389.    do center with 0,40,"","PopDice (c) 1992"
  390.    
  391.    *-- loop until user pressed such keys as <Enter> or <Esc> ...
  392.    do while .t.
  393.       store space(10) to m->cDice  && blank out field
  394.       @2,2 say "Enter dice description: " get m->cDice;
  395.          message "Examples: 6 (1d6), d6, 3d6, 3d6+1, 3d6-1 ..."
  396.       set cursor on
  397.       read
  398.       set cursor off
  399.       if len(trim(m->cDice)) = 0  && len  = 0, we're done
  400.          exit
  401.       endif
  402.       if at("D",upper(m->cDice)) = 0  && parsedice() requires 
  403.                                       && xD at front ...
  404.          m->cDice = "1d"+m->cDice
  405.       endif
  406.       if upper(left(m->cDice,1)) = "D"  && must be at least 1 ...
  407.          m->cDice = "1" + m->cDice
  408.       endif
  409.       @4,7 say "   Dice Rolled: "+m->cDice   
  410.                                 && display what's being done
  411.       @5,0 clear                && clear out messages, etc.
  412.       do center with 6,40,"rg+/r",". . . Calculating . . ."
  413.       *-- do it ... and display it
  414.       @5,7 say "Value returned: "+ltrim(str(parsedice(m->cDice)))
  415.       @6,0 clear
  416.    
  417.    enddo
  418.    
  419.    *-- cleanup
  420.    release window wPop
  421.    restore screen from sPop
  422.    release screen sPop
  423.    set cursor &cCursor.
  424.    
  425. RETURN
  426. *-- EoP: PopDice
  427.  
  428. *-----------------------------------------------------------------------
  429. *-- EoP: FRPG.PRG
  430. *-----------------------------------------------------------------------
  431.